{-# OPTIONS_GHC -XTemplateHaskell -XRankNTypes#-}
module Text.XML.Light.Xmlable.Types where

import Text.XML.Light
import Text.XML.Light.Xmlable.Utils
import Data.Time.LocalTime
import Data.Time.Format
import Data.Maybe
import Data.List
import System.Locale
import qualified Data.Map as Map
import Data.Function
import Control.Arrow

errorXmlable :: (Show a) => [Char] -> a -> b
errorXmlable s e = error $ unlines ["Xmlable: fromElement :: Element -> " ++ s ++ ": Element is invalid:", show e]

getSimpleStr :: Element -> String
getSimpleStr (Element _ _ [ Text (CData _ s _) ] _) = s
getSimpleStr e = error $ unlines ["Xmlable getSimpleStr: Element is invalid:", show e]

attrToContent :: Attr -> Content
attrToContent (Attr qn val) = Elem blank_element { 
        elName = qn,
        elContent = [ Text $ blank_cdata { cdData = val } ]
    }
    
mkAttr :: (QName, (Element, Bool)) -> [Attr] -> [Attr]
mkAttr (s, (e, True)) = (Attr s (getSimpleStr e) :)
mkAttr (_, (_, False)) = id

mkContent :: (QName, (Element, Bool)) -> [Content] -> [Content]
mkContent (s, (e, False)) = (Elem e { elName = s } :)
mkContent (_, (_, True)) = id

elemAndSimple :: (Xmlable a) => a -> (Element, Maybe Bool)
elemAndSimple = (toElement &&& isSimple)

mkFoldr :: forall a b c d . ((b, (c, d)) -> [a] -> [a]) -> [(b, (c, Maybe d))] -> [a]
mkFoldr f = foldr f [] . map (second $ second fromJust) . filter (isJust . snd . snd) 

mkAttrs :: [(QName, (Element, Maybe Bool))] -> [Attr]
mkAttrs xs = mkFoldr mkAttr xs

mkContents :: [(QName, (Element, Maybe Bool))] -> [Content]
mkContents xs = mkFoldr mkContent xs

elemsFromElement :: Element -> [Element]
elemsFromElement (Element _ attrs cs _) = onlyElems $ map attrToContent attrs ++ cs

valFromElems :: (Xmlable a) => String -> [QName] -> [Element] -> Int -> a
valFromElems err names xs n 
    | isNothing get = errorXmlable err xs
    | otherwise = fromElement $ fromJust get
    where
        get = find ((names !! n ==) . elName) xs

class Xmlable a where
    toElement :: a -> Element
    fromElement :: Element -> a
    isSimple :: a -> Maybe Bool
    listName :: a -> String
    toXsdType :: a -> String
    isChar :: a -> Bool
    xToChar :: a -> Char
    xFromChar :: Char -> a
    -- default realisations
    isSimple = const (Just False)
    toXsdType _ = undefined
    isChar = const False
    xToChar = undefined
    xFromChar = undefined
    
    
toElementSimple :: (a -> String) -> a -> Element
toElementSimple f x = blank_element { elContent = [ Text $ blank_cdata { cdData = f x } ] }

fromElementSimple :: (String -> a) -> String -> Element -> a
fromElementSimple f _ (Element _ _ [Text (CData _ x _)] _) = f x
fromElementSimple _ err e = errorXmlable err e

instance Xmlable Char where
    toElement = toElementSimple (:[])
    fromElement e = fromElementSimple f "Char" e
        where
            f [] = errorXmlable "Char" e
            f (x:_) = x
    isSimple = const (Just True)
    listName = const "Chars"
    isChar = const True
    xToChar = id
    xFromChar = id
    
instance Xmlable Bool where
    toElement = toElementSimple (\b -> if b then "true" else "false")
    fromElement = fromElementSimple (== "true") "Bool"
    isSimple = const (Just True)
    listName = const "Bools"
    
instance Xmlable LocalTime where
    toElement = toElementSimple (formatTime defaultTimeLocale "%FT%X")
    fromElement = fromElementSimple (readTime defaultTimeLocale "%FT%T" . fst . break (=='.')) "LocalTime"
    isSimple = const (Just True)
    listName = const "LocalTimes"

instance Xmlable Float where
    toElement = toElementSimple show
    fromElement = fromElementSimple read "Float"
    isSimple = const (Just True)
    listName = const "Floats"

instance Xmlable Integer where
    toElement = toElementSimple show
    fromElement = fromElementSimple read "Integer"
    isSimple = const (Just True)
    listName = const "Integers"
    
instance Xmlable a => Xmlable (Maybe a) where
    toElement Nothing = blank_element
    toElement (Just x) = toElement x
    fromElement (Element (QName "" Nothing Nothing) [] [] _) = Nothing
    fromElement e = Just (fromElement e)
    isSimple (Just x) = isSimple x
    isSimple Nothing = Nothing
    listName (Just x) = listName x
    listName Nothing = ""

instance (Xmlable a) => Xmlable [a] where
    isSimple [] = Nothing
    isSimple (x:_) = Just (isChar x)
    listName = listName' . filter (not . null . listName)
        where
            listName' [] = ""
            listName' (x:_) = "ListOf" ++ listName x
    toElement [] = blank_element
    toElement xs = if isChar (head xs) then blank_element { elContent = [ Text $ CData CDataRaw (map xToChar xs) Nothing ] } 
            else Element { 
                    elName = QName { qName = listName . head $ xs, qURI = qURI . elName . toElement . head $ xs, qPrefix = Nothing },
                    elAttribs = [],
                    elContent = map (Elem . toElement) xs,
                    elLine = Nothing
                }
    fromElement e
        | null . elContent $ e = []
        | null getList = []
        | isChar $ head getList = map xFromChar . concatMap showContent . elContent $ e
        | otherwise = getList
        where
            getList = [fromElement e' | Elem e' <- elContent e]

data Item k v = Item k v

instance (Xmlable k, Xmlable v) => Xmlable (Item k v) where
    listName = const "Items"
    toElement (Item k v) = Element { 
            elName = name "Item",
            elAttribs = mkAttrs args,
            elContent = mkContents args,
            elLine = Nothing
        }
        where
            name = $(qualName ''Item)
            args = [(name "key", elemAndSimple k), (name "value", elemAndSimple v)]

    fromElement e = fromList $ elemsFromElement e
        where
            name = $(qualName ''Item)
            fromList xs = Item (getVal 0) (getVal 1)
                where
                    getVal n = valFromElems "Item (List)" [name "key", name "value"] xs n
                    
instance (Xmlable k, Xmlable a, Ord k) => Xmlable (Map.Map k a) where
    toElement = toElement . map (uncurry Item) . Map.toList
    fromElement = Map.fromList . map (\(Item k v) -> (k, v)) . fromElement
    listName = listName' . filter (not . null . listName) . map (uncurry Item) . Map.toList
        where
            listName' [] = ""
            listName' (x:_) = "MapOf" ++ listName x

mkURI :: [Char] -> [Char]
mkURI mn = "http://haskell.org/" ++ change mn
    where 
        change = change' . break (=='.')
        change' (a,b)
            | null b = a
            | not ('.' `elem` b) = a
            | otherwise = a ++ ('/' : change (tail b))
